home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / win / pascal / fontlst.exe / FONTLIST.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-06-28  |  13.1 KB  |  434 lines
  1. program    FontList;
  2.  
  3. uses
  4.     WObjects, WinTypes, WinProcs,Strings;
  5.  
  6. {$I fontlist.inc}
  7. {$R fontlist.res}
  8.  
  9. type
  10.     PEnumer = ^TEnumer;
  11.     TEnumer = record
  12.         hGMem        : THandle;
  13.         nCount    : Integer;
  14.     end;
  15.  
  16.     PFont = ^TFont;
  17.     TFont = record
  18.         nFontType    : Integer;
  19.         lf                : TLogFont;
  20.         tm                : TTextMetric;
  21.     end;
  22.  
  23.  
  24.     TFontApp = object ( TApplication )
  25.         procedure    InitMainWindow; virtual;
  26.     end;
  27.  
  28.     PFontWindow    = ^TFontWindow;
  29.     TFontWindow = object ( TWindow )
  30.         HaveInfo    : Boolean;
  31.         Enumer1,
  32.         Enumer2        : TEnumer;
  33.         EnumFacesProc    : TFarProc;
  34.         EnumFontsProc    : TFarProc;
  35.         cxChar,
  36.         cyChar            : Integer;
  37.         nCurrent        : Integer;
  38.         CurrentDC    : Word;
  39.         constructor    Init ( AParent: PWindowsObject; ATitle: PChar );
  40.         destructor    Done; virtual;
  41.         procedure    Paint ( PaintDC: HDC; var PaintInfo: TPaintStruct ); virtual;
  42.         procedure    Redraw;
  43.         procedure    SelectScreen( var Message: TMessage );
  44.             virtual    cm_First + cm_Screen;
  45.         procedure    SelectPrinter ( var Message: TMessage );
  46.             virtual    cm_First + cm_Printer;
  47.         procedure    WMDevModeChange ( var Message: TMessage );
  48.             virtual    wm_First + wm_DevModeChange;
  49.         procedure    WMFontChange( var Message: TMessage );
  50.             virtual    wm_First + wm_FontChange;
  51.         procedure    WMVScroll ( var Message: TMessage );
  52.             virtual    wm_First + wm_VScroll;
  53.     end;
  54.  
  55. var
  56.     FontApp: TFontApp;
  57.  
  58.  
  59. function    EnumAllFaces ( lf : PLogFont; tm : PTextMetric;
  60.                                                  FontType: Integer; Enumer : PEnumer ) : Integer; export;
  61. var
  62.     lpFaces    : Pointer;
  63. begin
  64.     EnumAllFaces := 0;
  65.     if GlobalReAlloc ( Enumer^.hGMem,
  66.                                          LF_FACESIZE * ( 1 + Enumer^.nCount ),
  67.                                          GMEM_MOVEABLE ) = 0 then
  68.         Exit;
  69.     lpFaces := GlobalLock ( Enumer^.hGMem );
  70.     StrCopy ( PChar(LongInt(lpFaces)+ Enumer^.nCount * lf_FaceSize), lf^.lfFaceName );
  71.     GlobalUnlock ( Enumer^.hGMem );
  72.     Inc(Enumer^.nCount);
  73.     EnumAllFaces := 1;
  74. end;
  75.  
  76. function    EnumAllFonts ( lf : PLogFont; tm : PTextMetric;
  77.                                                  nFontType: Integer; Enumer : PEnumer ) : Integer; export;
  78. var
  79.     font    : PFont;
  80. begin
  81.     EnumAllFonts := 0;
  82.     if GlobalReAlloc ( Enumer^.hGMem,
  83.                                          sizeof ( TFont )* ( 1 + Enumer^.nCount ),
  84.                                          gmem_MOVEABLE ) = 0 then
  85.         Exit;
  86.     font := PFont(GlobalLock ( Enumer^.hGMem ));
  87.     font := PFont(Longint(font)+(Enumer^.nCount * sizeof ( TFont ) ) );
  88.     font^.nFontType := nFontType;
  89.     font^.lf := lf^;
  90.     font^.tm := tm^;
  91.     GlobalUnlock ( Enumer^.hGMem );
  92.     Inc(Enumer^.nCount);
  93.     EnumAllFonts:= 1;
  94. end;
  95.  
  96. function     StrTok ( Src : PChar; Sep: PChar ): PChar;
  97. const
  98.     STSrc: PChar = NIL;
  99. var
  100.     l : Integer;
  101.     i : Integer;
  102.     Temp : PChar;
  103. begin
  104.     StrTok := NIL;
  105.     if Src <> NIL then
  106.         STSrc := Src;
  107.     if STSrc = NIL then
  108.         Exit;
  109.  
  110.     l := StrLen ( Sep );
  111.     for i := 0 to l-1 do
  112.     begin
  113.         Temp := StrScan ( STSrc, Sep[i] );
  114.         if Temp <> NIL then
  115.         begin
  116.             StrTok := STSrc;
  117.             Temp^ := #0;
  118.             STSrc := Temp + 1;
  119.             Exit;
  120.         end;
  121.     end;
  122.     StrTok := STSrc;
  123.     STSrc := NIL;
  124. end;
  125.  
  126.  
  127. function    GetPrinterIC : THandle;
  128. var
  129.     szPrinter : array[0..64] of Char;
  130.     szDevice, szDriver, szOutput : PChar;
  131. begin
  132.     GetProfileString ( 'windows','device','', szPrinter, 64 );
  133.     szDevice := StrTok ( szPrinter, ',' );
  134.     szDriver := StrTok ( NIL, ',' );
  135.     szOutput := StrTok ( NIL, ',' );
  136.     if (szDevice <> NIL ) and
  137.          (szDriver <> NIL ) and
  138.          (szOutput <> NIL ) then
  139.          GetPrinterIC := CreateIC ( szDriver, szDevice, szOutput, NIL )
  140.     else
  141.         GetPrinterIC := 0;
  142. end;
  143.  
  144.  
  145. procedure    Display ( PaintDC: HDC; cx,cy : Integer; Font: PFont );
  146. type
  147.     PCharArr = array[0..100] of PChar;
  148.     PPCharArr = ^PCharArr;
  149. const
  150.     F : TFont = ();
  151.     First: Integer = 0;
  152.     Last: Integer = 0;
  153.     Default: Integer = 0;
  154.     Break: Integer = 0;
  155.  
  156.     szYN : array[0..1] of PChar = ( 'No','Yes' );
  157.     szCS : array[0..3] of PChar = ( 'ANSI','?????','Kanji','OEM' );
  158.     szOP : array[0..3] of PChar = ( 'Default','String','Char','Stroke');
  159.     szCP : array[0..3] of PChar = ( 'Default','Char','Stroke','?????' );
  160.     szQU : array[0..3] of PChar = ( 'Draft','Default','Proof','?????' );
  161.     szP1 : array[0..3] of PChar = ( 'Default','Fixed','Variable','?????' );
  162.     szP2 : array[0..1] of PChar = ( 'Fixed','Variable' );
  163.     szFA : array[0..7] of PChar = ( 'Don''t Care','Roman','Swiss','Modern',
  164.                                                                     'Script','Decorative','?????','?????' );
  165.     szVR : array[0..1] of PChar = ( 'Stroke','Raster' );
  166.     szGD : array[0..1] of PChar = ( 'GDI','Device');
  167.  
  168.     shorts: array[0..19] of record
  169.         x : Integer;
  170.         y : Integer;
  171.         szFmt    : PChar;
  172.         PData : ^Integer;
  173.     end =
  174.     (
  175.         ( x:1; y:1; szFmt:'LOGFONT'; PData:NIL ),
  176.         ( x:1; y:2; szFmt:'-------'; PData:NIL ),
  177.         ( x:1; y:3; szFmt:'Height:      %10d'; PData:@f.lf.lfHeight),
  178.         ( x:1; y:4; szFmt:'Width:       %10d'; PData:@f.lf.lfWidth),
  179.         ( x:1; y:5; szFmt:'Escapment    %10d'; PData:@f.lf.lfEscapement),
  180.         ( x:1; y:6; szFmt:'Orientation: %10d'; PData:@f.lf.lfOrientation),
  181.         ( x:1; y:7; szFmt:'Weight:      %10d'; PData:@f.lf.lfWeight),
  182.         ( x:28; y:1; szFmt:'TEXTMETRIC'; pData:NIL),
  183.         ( x:28; y:2; szFmt:'----------'; pData:NIL),
  184.         ( x:28; y:3; szFmt:'Height:       %5d'; PData:@f.tm.tmHeight),
  185.         ( x:28; y:4; szFmt:'Ascent:       %5d'; PData:@f.tm.tmAscent),
  186.         ( x:28; y:5; szFmt:'Descent:      %5d'; PData:@f.tm.tmDescent),
  187.         ( x:28; y:6; szFmt:'Int. Leading: %5d'; PData:@f.tm.tmInternalLeading),
  188.         ( x:28; y:7; szFmt:'Ext. Leading: %5d'; PData:@f.tm.tmExternalLeading),
  189.         ( x:28; y:8; szFmt:'Ave. Width:   %5d'; pData:@f.tm.tmAveCharWidth),
  190.         ( x:28; y:9; szFmt:'Max. Width:   %5d'; pData:@f.tm.tmMaxCharWidth),
  191.         ( x:28; y:10; szFmt:'Weight:       %5d'; pData:@f.tm.tmWeight),
  192.         ( x:51; y:10; szFmt:'Overhang:     %10d'; pData:@f.tm.tmOverhang),
  193.         ( x:51; y:11; szFmt:'Digitized X:  %10d'; pData:@f.tm.tmDigitizedAspectX ),
  194.         ( x:51; y:12; szFmt:'Digitized Y;  %10d'; pData:@f.tm.tmDigitizedAspectY));
  195.  
  196.     bytes : array[0..3] of record
  197.         x,y: Integer; szFmt: PChar; pData: ^Byte;
  198.     end =
  199.     ( ( x:51; y:3; szFmt:'FirstChar:    %10d'; pData:@First),
  200.         ( x:51; y:4; szFmt:'Last Char:    %10d'; pData:@Last),
  201.         ( x:51; y:5; szFmt:'Default Char: %10d'; pData:@Default),
  202.         ( x:51; y:6; szFmt:'Break Char:   %10d'; pData:@Break) );
  203.  
  204.     strs : array[0..16] of record
  205.         x,y: Integer; szFmt: PChar; pData:^Byte; szArray:PPCharArr;
  206.         sAnd: Integer; sShift: Integer;
  207.     end =
  208.     ( ( x:1; y:8; szFmt:'Italic:      %10s';pData:@f.lf.lfItalic; szArray:@szYn; sAnd:1; sShift:0),
  209.         ( x:1; y:9; szFmt:'Underline:   %10s';pData:@f.lf.lfUnderline; szArray:@szYN; sAnd:1; sShift:0),
  210.         ( x:1; y:10; szFmt:'Strike-Out   %10s';pData:@f.lf.lfStrikeOut; szArray:@szYN; sAnd:1; sShift:0),
  211.         ( x:1; y:11; szFmt:'Char Set:    %10s';pData:@f.lf.lfCharSet; szArray:@szCS; sAnd:$C0; sShift:6),
  212.         ( x:1; y:12; szFmt:'Out  Prec:   %10s';pData:@f.lf.lfOutPrecision; szArray:@szOP; sAnd:3; sShift:0),
  213.         ( x:1; y:13; szFmt:'Clip Prec:   %10s';pData:@f.lf.lfClipPrecision; szArray:@szCP; sAnd:3; sShift:0),
  214.         ( x:1; y:14; szFmt:'Quality:     %10s';pData:@f.lf.lfQuality; szArray:@szQU; sAnd:3; sShift:0),
  215.         ( x:1; y:15; szFmt:'Pitch:       %10s';pData:@f.lf.lfPitchAndFamily; szArray:@szP1; sAnd:3; sShift:0),
  216.         ( x:1; y:16; szFmt:'Family:      %10s';pData:@f.lf.lfPitchAndFamily; szArray:@szFA; sAnd:$70; sShift:4),
  217.         ( x:28; y:11; szFmt:'Italic:       %5s';pData:@f.tm.tmItalic; szArray:@szYN; sAnd:1; sShift:0),
  218.         ( x:28; y:12; szFmt:'Underline:    %5s';pData:@f.tm.tmUnderlined; szArray:@szYN; sAnd:1; sShift:0),
  219.         ( x:28; y:13; szFmt:'Strike-Out:   %5s';pData:@f.tm.tmStruckOut; szArray:@szYN; sAnd:1; sShift:0),
  220.         ( x:51; y:7; szFmt:'Pitch:        %10s';pData:@f.tm.tmPitchAndFamily; szArray:@szP2; sAnd:1; sShift:0),
  221.         ( x:51; y:8; szFmt:'Family:       %10s';pData:@f.tm.tmPitchAndFamily; szArray:@szFA; sAnd:$70; sShift:4),
  222.         ( x:51; y:9; szFmt: 'Char Set:     %10s';pData:@f.tm.tmCharSet; szArray:@szCS; sAnd:$C0; sShift:6),
  223.         ( x:36; y:15; szFmt:'Font Type: %6s';pData:@f.nFontType; szArray:@szVR; sAnd:1; sShift:0),
  224.         ( x:55; y:15; szFmt:'%s'; pData:@f.nFontType; szArray:@szGD; sAnd:2; sShift:1 ));
  225.  
  226.  
  227. var
  228.     szBuffer : array[0..80] of Char;
  229.     i: Integer;
  230.     szParms : array[0..0] of Pointer;
  231. begin
  232.     f := Font^;
  233.     First := f.tm.tmFirstChar;
  234.     Last := f.tm.tmLastChar;
  235.     Default := f.tm.tmDefaultChar;
  236.     Break := f.tm.tmBreakChar;
  237.     for i := 0 to 19 do
  238.         TextOut ( PaintDC, cx * shorts[i].x, cy * shorts[i].y, szBuffer,
  239.             wvsprintf ( szBuffer, shorts[i].szFmt, shorts[i].pData^) );
  240.     for i := 0 to 3 do
  241.         TextOut ( PaintDC, cx * bytes[i].x, cy * bytes[i].y, szBuffer,
  242.             wvsprintf ( szBuffer, bytes[i].szFmt, bytes[i].pData^) );
  243.     for i := 0 to 16 do
  244.         TextOut ( PaintDC, cx * strs[i].x, cy * strs[i].y, szBuffer,
  245.             wvsprintf ( szBuffer, strs[i].szFmt,
  246.                 strs[i].szArray^[(strs[i].pData^ and strs[i].sAnd) shr strs[i].sShift]) );
  247.     StrCopy(szBuffer ,'Face Name: ');
  248.     StrCat( szBuffer, f.lf.lfFaceName );
  249.     TextOut( PaintDC, cx * 36, cy * 16, szBuffer, StrLen ( szBuffer ) );
  250. end;
  251.  
  252.  
  253.  
  254. procedure    TFontApp.InitMainWindow;
  255. begin
  256.     MainWindow := New ( PFontWindow, Init( NIL, 'Font Enumeration' ) );
  257. end;
  258.  
  259. constructor    TFontWindow.Init ( AParent: PWindowsObject; ATitle: PChar );
  260. var
  261.     DC: HDC;
  262.     tm: TTextMetric;
  263. begin
  264.     TWindow.Init ( AParent, ATitle );
  265.     Attr.Style := Attr.Style or ws_VScroll or ws_HScroll;
  266.     Attr.Menu := LoadMenu ( HInstance, 'MAINMENU');
  267.  
  268.     HaveInfo := FALSE;
  269.     FillChar ( Enumer1, sizeof ( Enumer1 ), 0 );
  270.     FillChar ( Enumer2, sizeof ( Enumer2 ), 0 );
  271.     EnumFontsProc := MakeProcInstance( @EnumAllFonts, hInstance );
  272.     EnumFacesProc := MakeProcInstance( @EnumAllFaces, hInstance );
  273.     CurrentDC := cm_Screen;
  274.     CheckMenuItem ( Attr.Menu, CurrentDC, mf_Checked );
  275.     DC := GetDC ( hWindow );
  276.     SelectObject ( DC, GetStockObject ( System_Fixed_Font ) );
  277.     GetTextMetrics ( DC, tm );
  278.     cxChar := tm.tmAveCharWidth;
  279.     cyChar := tm.tmHeight + tm.tmExternalLeading;
  280.     ReleaseDC ( hWindow, DC );
  281. end;
  282.  
  283. destructor    TFontWindow.Done;
  284. begin
  285.     if Enumer2.hGMem <> 0 then
  286.         GlobalFree ( Enumer2.hGMem );
  287.     TWindow.Done;
  288. end;
  289.  
  290. procedure    TFontWindow.Paint( PaintDC: HDC; var PaintInfo: TPaintStruct );
  291. var
  292.     DC: HDC;
  293.     Faces: Pointer;
  294.     Font: PFont;
  295.     OldFont    : HFONT;
  296.     i: Integer;
  297. begin
  298.     TWindow.Paint ( PaintDC, PaintInfo );
  299.     if not HaveInfo then
  300.     begin
  301.         if Enumer2.hGMem <> 0 then
  302.             GlobalFree ( Enumer2.hGMem );
  303.         Enumer1.hGMem := GlobalAlloc ( gmem_Fixed, 1 );
  304.         Enumer1.nCount := 0;
  305.  
  306.         Enumer2.hGMem := GlobalAlloc ( gmem_Fixed, 1 );
  307.         Enumer2.nCount := 0;
  308.  
  309.         if ( Enumer1.hGMem = 0 ) or ( Enumer2.hGMem = 0 ) then
  310.         begin
  311.             FontApp.Error( em_OutOfMemory );
  312.             Exit;
  313.         end;
  314.  
  315.         if ( CurrentDC = cm_Screen ) then
  316.             DC := CreateIC ( 'DISPLAY', NIL, NIL, NIL )
  317.         else
  318.             DC := GetPrinterIC;
  319.  
  320.         if DC <> 0 then
  321.         begin
  322.             if EnumFonts ( DC, NIL, EnumFacesProc, @Enumer1 ) = 0 then
  323.             begin
  324.                 FontApp.Error ( em_OutOfMemory );
  325.                 Exit;
  326.             end;
  327.             Faces := GlobalLock ( Enumer1.hGMem );
  328.             for i :=  0 to ENumer1.NCount - 1 do
  329.             begin
  330.                 if EnumFonts ( DC, Pointer(Longint(Faces)+ (i * lf_FaceSize) ),
  331.                                              EnumFontsProc, @Enumer2 ) = 0 then
  332.                 begin
  333.                     FontApp.Error ( em_OutOfMemory );
  334.                     Exit;
  335.                 end;
  336.             end;
  337.  
  338.             GlobalUnlock ( Enumer1.hGMem );
  339.             Dec ( Enumer2.nCount );
  340.             DeleteDC ( DC );
  341.             HaveInfo := True;
  342.         end;
  343.         GlobalFree ( Enumer1.hGMem );
  344.         SetScrollRange ( HWindow, sb_Vert, 0, Enumer2.nCount, FALSE );
  345.         SetScrollPos ( HWindow, sb_Vert, 0, TRUE );
  346.         nCurrent := 0;
  347.     end;
  348.  
  349.     if HaveInfo then
  350.     begin
  351.         SelectObject ( PaintDC, GetStockObject ( System_Fixed_Font ) );
  352.         Font := PFont ( GlobalLock ( Enumer2.hGMem ) );
  353.         Font := PFont(Longint(Font)+ (nCurrent * sizeof ( TFont ) ));
  354.         Display ( PaintDC, cxChar, cyChar, Font );
  355.         OldFont := SelectObject ( PaintDC, CreateFontIndirect ( Font^.lf ) );
  356.         TextOut ( PaintDC, 1 * cxChar, 19 * cyChar,
  357.             'AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz', 52 );
  358.         GlobalUnlock ( Enumer2.hGMem );
  359.         DeleteObject ( SelectObject( PaintDC, OldFont ) );
  360.     end;
  361. end;
  362.  
  363. procedure    TFontWindow.Redraw;
  364. begin
  365.     HaveInfo := FALSE;
  366.     InvalidateRect ( HWindow, NIL, TRUE );
  367. end;
  368.  
  369.  
  370. procedure    TFontWindow.SelectScreen( var Message: TMessage );
  371. var
  372.     Menu: HMenu;
  373. begin
  374.     Menu := GetMenu ( HWindow );
  375.     CheckMenuItem ( Menu, CurrentDC, mf_Unchecked );
  376.     CheckMenuItem ( Menu, cm_Screen, mf_Checked );
  377.     CurrentDC := cm_Screen;
  378.     Redraw;
  379. end;
  380.  
  381.  
  382. procedure    TFontWindow.SelectPrinter ( var Message: TMessage );
  383. var
  384.     Menu: HMenu;
  385. begin
  386.     Menu := GetMenu ( HWindow );
  387.     CheckMenuItem ( Menu, CurrentDC, mf_Unchecked );
  388.     CheckMenuItem ( Menu, cm_Printer, mf_Checked );
  389.     CurrentDC := cm_Printer;
  390.     Redraw;
  391. end;
  392.  
  393.  
  394. procedure    TFontWindow.WMDevModeChange ( var Message: TMessage );
  395. begin
  396.     Redraw;
  397. end;
  398.  
  399. procedure    TFontWIndow.WMFontChange( var Message: TMessage );
  400. begin
  401.     Redraw;
  402. end;
  403.  
  404.  
  405. procedure    TFontWindow.WMVScroll ( var Message: TMessage );
  406. begin
  407.     case Message.wParam of
  408.         sb_Top: nCurrent := 0;
  409.         sb_Bottom: nCurrent := Enumer2.nCount;
  410.         sb_LineUp,
  411.         sb_PageUp: Dec(nCurrent);
  412.         sb_LineDown,
  413.         sb_PageDown: Inc ( nCurrent );
  414.         sb_ThumbPosition: nCurrent := Message.lParamLo;
  415.         else
  416.             Exit;
  417.     end;
  418.     if nCurrent < 0 then
  419.         nCurrent := 0
  420.     else
  421.     if nCurrent > Enumer2.nCount then
  422.         nCurrent := Enumer2.nCount;
  423.     SetScrollPos ( HWindow, sb_Vert, nCurrent, TRUE );
  424.     InvalidateRect ( HWindow, NIL, TRUE );
  425. end;
  426.  
  427.  
  428.  
  429.  
  430. begin
  431.     FontApp.Init ( 'FontList' );
  432.     FontApp.Run;
  433.     FontApp.Done;
  434. end.